COMMENT ⊗   VALID 00012 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	entry begin comment The output module of METAFONT.
C00007 00003	Routines for time of day and file information (highly system-dependent)
C00010 00004	openofil
C00016 00005	Routines for proof mode.
C00037 00006	Routines for chr mode.
C00043 00007	Routines for fnt mode.
C00049 00008	Routines for tfx mode.
C00056 00009	Routines for Alphatype fonts
C00083 00010	internal procedure initout # get TEXOUT started properly
C00084 00011	internal procedure finishchar # outputs a finished character
C00086 00012	internal procedure closeout # finishes off the output
C00088 ENDMK
C⊗;
entry; begin comment The output module of METAFONT.

(It is wise to read MFSYS and the raster formats explained in MFRAST
before going very deeply into the following code.)

Each MFOUT module is intended to handle a set of output devices and modes at some
particular installation. The following procedures are required:

	initout			gets the output module started initially
	finishchar		called when a character has been fully specified
	closeout		finishes the output
	entersym		when a symbol has become "known" in proof mode
	clearchar		initialize for a new character

This routine is designed for output to the Xerox Graphics Printer (XGP)
and to the Alphatype CRS printer at Stanford. Routines for other devices
will probably have a rather similar structure;

comment Certain bits of the "control" variable govern output modes supported:
	'1000	proof mode
	'2000	chr file mode
	'4000	make TEX information file
	'10000	make xgp font
	'20000	make Alphatype CRS font
	'400000 label the points in proof mode
;
comment Certain bits of the "control" variable govern the on-line output:
	'1000000	display each character after it has been fully drawn
;

require "MFHDR.SAI" source_file;
internaldef symbolic=⊂(control land '1000)⊃ # keep list of "known" xy-variables;
define proofmode=⊂(control land '1000)⊃, chrmode=⊂(control land '2000)⊃,
	fntmode=⊂(control land '10000)⊃, crsmode=⊂(control land '20000)⊃;
internaldef tfxmode=⊂(control land '4000)⊃;
define points=⊂(control land '400000)⊃;
define chardisplay=⊂(control land '1000000)⊃;

internaldef brksize=10 # the number of distinct breaks per character;
internal integer array brktab[0:brksize+1] # breaks in increasing order;
internal integer brkptr # current number of entries in brktab;

preload_with 0,1,2,27,3,24,28,33,4,17,25,31,29,12,34,14,5,8,18,36,26,23,32,16,
	30,11,13,7,35,22,15,10,6,21,9,20,19; saf integer array bit_id[0:36];
comment Routines for time of day and file information (highly system-dependent);
comment These routines are due to Hans Moravec;

integer octaltime # lefthalf is encoded date, righthalf is seconds past midnite;
string procedure daytime;
begin comment returns date and time down to the second, as a string;
integer d,t,sw,sd; string s;
string procedure cvs2(integer i);
return((((i div 10) mod 10)+"0")&((i mod 10)+"0"));
t←octaltime land '777777; d←octaltime lsh -18;
getformat(sw,sd); setformat(0,7);
s←cvs((d mod 31)+1)&", "&cvs((d div 31)div 12 + 1964);
setformat(sw,sd);
return((case ((d div 31) mod 12) of
	("January","February","March","April","May","June",
	"July","August","September","October","November","December"))&" "&
	s&"    "&cvs2(t div (60*60))&":"&
	cvs2((t div 60) mod 60)&":"&cvs2(t mod 60));
end;

string procedure filinf(integer channel);
begin comment returns file name, extension, and area of the file open on channel;
define POPJ(A,B)=⊂'263000000000 lor (A lsh 23) lor B⊃;
define MTAPE(A,B)=⊂'072000000000 lor (A lsh 23) lor B⊃;
saf integer array mtp[0:3], ret[0:6], cod[0:2];
string fn,ext,ppn,t; integer i;
mtp[0]←cvsix("GODMOD"); mtp[1]←'14; mtp[2]←(-5 lsh 18) lor location(ret[0]);
cod[0]←MTAPE(channel,location(mtp[0])); cod[1]←cod[2]←POPJ('17,0);
START_CODE PUSHJ '17,ACCESS(COD[0]); END;

fn←cvxstr(ret[1]); while length(fn)>0 ∧ fn[∞ to ∞]=" " DO fn←fn[1 to ∞-1];
ext←cvxstr(ret[2] land '777777000000);
while length(ext)>0 ∧ ext[∞ to ∞]=" " do ext←ext[1 to ∞-1];
ppn←cvxstr(ret[4]); t←ppn[1 to 3]&","&ppn[4 to 6];
ppn←""; for i←1 thru 7 do if t[i to i]≠" " then ppn←ppn&t[i to i];
return(fn&"."&ext&"["&ppn&"]");
end;
comment openofil;

internal string maintitle # symbolic description of the font being generated;
internal string ofilname # output file name, set by first input;
string timeofday # time to be used on output;
internaldef numberofmodes=5 # number of output modes supported;
internaldef tfx=1,xgpfnt=3,proof=2,alf=5,chrs=4 # symbolic names of modes;
comment Use odd-numbered modes for files with binary output;
saf integer array ochan[1:numberofmodes] # channels for output;
saf string array ofilext[1:numberofmodes] # file name extensions;
saf string array flname[1:numberofmodes] # actual file names opened;
boolean no_output_yet # no characters output yet;
integer prfpno # page number in proof mode;
string prfheader # time of day and filename for proof mode;
integer fntptr # number of words output in fntmode or preamble words in crsmode;
integer alfptr # number of words output in crsmode;
internaldef initblocks=6 # number of blocks of preamble to font files;
internal saf integer array fntdir[0:'200*initblocks-1] # first blocks of font file;

integer procedure openofil(integer t) # initializes output for mode t;
begin comment This procedure is called when output for mode t is requested.
It opens the file and gets things started and returns the channel number;
integer i # loop index; string fn # output file name;
if ochan[t]≥0 then return(ochan[t]);
open(ochan[t]←getchan,"DSK",if t land 1 then 8 else 0,0,2,0,0,eof);
if not ofilname then ofilname←"mfput";
fn←ofilname&ofilext[t];
loop	begin enter(ochan[t],fn,eof);
	if eof then
		begin print(nextline,"I can't write on file ",fn,
		nextline,"Output file = ");
		fn←inchwl;
		end
	else done;
	end;
flname[t]←fn;
case t of begin
[xgpfnt] begin string longtitle; 
if ochan[alf]≥0 then errorstop("Incompatible resolution");
for i←0 thru '237 do fntdir[i]←0;
longtitle←maintitle&(nextline&"Written by METAFONT, ")&timeofday;
for i←'240 thru '377 do fntdir[i]←cvasc(longtitle[5*(i-'237)-4 for 5]);
arryout(ochan[xgpfnt],fntdir[0],'400) # will be overwritten later;
fntptr←'400; fntdir['203]←maxht end;
[chrs] out(ochan[chrs],maintitle&(nextline&"Based on .CHR file written by METAFONT, ")&
	timeofday&(nextline&"⊗"&nextline)) # font description page;
[proof] begin out(ochan[proof],"/LMAR=50/TMAR=50/RMAR=1700/BMAR=1/PMAR=0/XLINE=0"&
"/FONT#0=NGR13/FONT#1=FIG/END") # preamble for xgp server;
prfpno←0; prfheader←timeofday&"     "&filinf(ochan[proof])&"     Page " end;
[alf] begin if ochan[xgpfnt]≥0 then errorstop("Incompatible resolution");
for i←0 thru '177 do fntdir[i]←0; fntdir['200]←octaltime;
fntdir['201]←(1365 lsh hw)+2047; fntptr←'204;
arryout(ochan[alf],fntdir[0],'200*initblocks) # will be overwritten later;
alfptr←initblocks*'200 end;
else comment do nothing;
 end;
return(ochan[t]);
end;
comment Routines for proof mode.

In proof mode, all of the xy-variables are remembered in a special table
as soon as both coordinates become known. This table is organized as a
doubly threaded binary search tree, ordered by decreasing $y$ coordinate,
and for fixed $y$ by increasing $x$ coordinate (i.e., top to bottom, left to right).
The tree nodes have several fields:
	llink[p]	left son (if $>p$) or inorder predecessor (if $≤p$)
	rlink[p]	right son (if $>p$) or inorder successor (if $≤p$)
	ycoord[p]	$y$ coordinate of the point
	xcoord[p]	$x$ coordinate of the point
	strng[p]	symbolic name of the point (to be put into the label box)
	xll[p],yll[p]	coordinates of lower left corner of point label box
	xur[p],yur[p]	coordinates of upper right corner of point label box
	prevbox[p]	pointer to previous point label box, ordered by \\{yll}
Hidden points have strng[p] null.
We have $\\{rlink}[0]=0$ and \\{llink}[0] points to the root of the tree.
The smallest unused node is \\{tptr}. To set the tree empty, one sets
$\\{llink}[0]←0$ and $$\\{tptr}←1$. The fields \\{xll}, \\{yll}, \\{xur}, \\{yur},
and \\{prevbox} are used only when allocating boxes for the point labels, just
before outputting the raster pattern. Actually \\{yur} is not stored in memory,
since $\\{yur}[p]$ always equals $\\{yll}[p]+10$.
;
internaldef proofmemsize=50 # size of proof mode tables;
integer saf array llink,rlink,ycoord,xcoord,xll,yll,xur,prevbox[0:proofmemsize-1];
string saf array strng[0:proofmemsize-1];
integer tptr # end of tree;
integer bxptr # pointer to last point label box (head of the \\{prevbox} list);

internal procedure proofins(integer xco,yco; string s) # inserts into tree;
begin integer q,r # pointer variables;
label moveleft,moveright,insert # go here to move downward in the tree;
label compare # go here to decide where to move next in the tree;
r←0;
moveleft: q←llink[r]; if q≤r then
	begin llink[r]←tptr; rlink[tptr]←r; llink[tptr]←q; go to insert;
	end;
r←q;
compare: if yco>ycoord[r] then go to moveleft;
if yco<ycoord[r] or xco>xcoord[r] then go to moveright;
if xco<xcoord[r] then go to moveleft;
return # this point duplicates one that's already present;
moveright: q←rlink[r]; if q≤r then
	begin rlink[r]←tptr; llink[tptr]←r; rlink[tptr]←q; go to insert;
	end;
r←q; go to compare;
insert: ycoord[tptr]←yco; xcoord[tptr]←xco; strng[tptr]←s;
tptr←tptr+1; if tptr≥proofmemsize then overflow(proofmemsize);
end;

procedure makeproof # Outputs the raster in printable form;
begin comment This routine figures out how to label the points, and then
it outputs the raster in a format that is printable with a special font.
The point label locations are computed in the following way: We go through
the points from top to bottom, left to right, and use the first available
position from a list of five choices:
	centered above the point
	centered to the left of the point
	centered to the right of the point
	centered below the point
	in the right margin below previous entries like this
(The last case always succeeds if the other four fail.) A position is
"available" if the corresponding box containing the symbolic name of the point
does not overlap with any previously placed boxes, and if this box is at least
two units away from every other point, measuring distance along vertical
and horizontal lines (Manhattan style). (The box is one unit away from
the point it corresponds to.)

Output for the XGP server is a sequence of 7-bit character codes of the following
types:
	'177&'001&'040&x1&x2, where x1&x2=x is a 14-bit binary number, x<4096
		means "move to column x"
	c, where c is a letter or digit or "."
		means "output character c in the FIG font and advance as many
			columns as c's width
	'012&'177&'003&y1&y2, where y1&y2=y is a 14-bit binary number
		means "move to row y (numbered from the top, increasing downwards)
	'015&'014&'177&'006&'001
		means "cut the paper at the current row (and select FIG font)"

;
simple string procedure twobytes(integer x) # changes x into x1&x2, a 14-bit code
	that represents 4x;
begin integer four_x; four_x←4*x; return((four_x lsh -7)&four_x);
end;
define movetocol(x)=⊂begin out(ch,'177&'001&'040);out(ch,twobytes(x-xl+50)) end⊃;
define movetorow(y)=⊂begin out(ch,'012&'177&'003);
	out(ch,twobytes(yhigh-(y)+50)) end⊃;
define cutpage=⊂'051&'014&'177&'006&'001⊃;

integer xl,xr,p,q,r,ch,y,x,state,curx;
integer yextra # coordinate for case 5 labels;
procedure clearstate # Outputs bit codes that have accumulated;
begin comment This procedure is used in the routine that puts out the raster.
If state = n > 0, we output the code for n grey cells
(where P=1 cell, Q=2, R=4, etc.), while if state = -m < 0 we output
the code for m blanks;
if state>0 then
	begin integer pt # power of 2;
	string chr # corresponding character;
	chr←"U"; pt←32 # the font has only "P", "Q", "R", "S", "T", and "U";
	loop	begin while state≥pt do
			begin out(ch,chr); state←state-pt; curx←curx+pt;
			end;
		if state=0 then return;
		pt←pt lsh -1; chr←chr-1;
		end;
	end;
curx←curx-state;
movetocol(curx);
state←0;
end;

xl←xleft*bitsperwd+(xrastmin+xpenmin) # leftmost bit position being output;
xr←xright*bitsperwd+(xrastmin+xpenmin+bitsperwd-1) # rightmost;
bxptr←0 # set list of active boxes empty;
yextra←yhigh;
p←0; if points then while llink[p]>p do p←llink[p] # start at topmost leftmost point;
while p do
	begin integer j # choice number for the label;
	integer m # four times the length of the label;
	integer x0,y0,x1,y1 # coordinates of the box;
	label advancep # go here when done with $p$;
	if xcoord[p]<xl or xcoord[p]>xr or ycoord[p]>yhigh or ycoord[p]<ylow
		or strng[p]=0
		then go to advancep # points out of range won't be shown;
	m←4*length(strng[p]);
	for j←1 thru 5 do
		begin integer q # runs through things that shouldn't clash;
		label reject # go here when case $j$ is illegal;
		case j of begin
		[1] begin x0←xcoord[p]-1-m; y0←ycoord[p]+1 end;
		[2] begin x0←xcoord[p]-3-2*m; y0←ycoord[p]-5 end;
		[3] begin x0←xcoord[p]+1; y0←ycoord[p]-5 end;
		[4] begin x0←xcoord[p]-1-m; y0←ycoord[p]-11 end;
		else begin x0←infty; done end
		  end;
		x1←x0+2+2*m; y1←y0+10;
		q←p # first we will check points just before $p$;
		loop	begin integer x,y,r # temporary storage;
			integer dist # Manhattan distance;
			if (r←llink[q])≤q then
				if r then q←r else done
			else	begin q←r; while (r←rlink[q])>q do q←r;
				end;
			comment The above lines moved $q$ backwards one;
			y←ycoord[q]; if y>y1+1 then done # no clash possible;
			if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
			else dist←0;
			x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
			x≤x0 then dist←dist+x0-x;
			if dist≤1 then go to reject;
			end;
		q←p # next we will check points just after $p$;
		loop	begin integer x,y,r # temporary storage;
			integer dist # Manhattan distance;
			if (r←rlink[q])≤q then
				if r then q←r else done
			else	begin q←r; while (r←llink[q])>q do q←r;
				end;
			comment The above lines moved $q$ forwards one;
			y←ycoord[q]; if y<y0-1 then done # no clash possible;
			if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
			else dist←0;
			x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
			x≤x0 then dist←dist+x0-x;
			if dist≤1 then go to reject;
			end;
		q←bxptr # finally we check that no overlap occurs;
		while q do
			begin
			if yll[q]>y1 then done;
			if x1≥xll[q] and x0≤xur[q] and y0≤yll[q]+10
				then go to reject;
			q←prevbox[q];
			end;
		done # all tests have been passed;
		reject: # this value of $j$ didn't work;
		end;
	if x0=infty then
		begin comment case 5;
		xll[p]←(xright+1-xleft)*bitsperwd;
		xur[p]←xll[p]+2*m+2;
		yextra←yextra-20; yll[p]←yextra;
		end
	else	begin comment case 1, 2, 3, or 4;
		xll[p]←x0; xur[p]←x1; yll[p]←y0;
		end;
	q←bxptr; r←0;
	while q and yll[q]<yll[p] do
		begin r←q; q←prevbox[q];
		end;
	prevbox[p]←q; if r then prevbox[r]←p else bxptr←p;
	advancep:
	if (r←rlink[p])≤p then p←r
	else	begin p←r; while (r←llink[p])>p do p←r;
		end;
	end;
comment Now all points have been output, so we output the raster pattern.
White spaces are handled by "skips", but grey cells are classified into
sixteen kinds according to the presence or absence of neighbors above, right,
below, or left of a cell. An ordinary cell has all four neighbors present.
Codes "A", "B", ..., "O" are used for the cases when one or more neighbors
is absent, using a binary code. The "fig" font uses this information to put
boundary lines at the edges.

The "fig" font is designed so that character "." placed at location (x,y) indicates
a big black dot centered on cell (x,y). The digits 0...9 and lower case letters
are designed to have a width of 8 cells, and so that the character will be
approximately centered in an 11x11 rectangle whose lower left corner is (x0,y0) and
whose upper right corner is (x0+10,y0+10) if the string begins at cell (x0+2,y0+8).

In the program below it is necessary to merge three kinds of output (point labels,
point dots, and grey cells) so that the XGP server gets its instructions in order
of decreasing y coordinates;

comment First we relink the point label boxes into down-the-page order and increase
the \\{xll} and \\{yll} coordinates to account for the font offset;
q←0; while bxptr do
	begin r←prevbox[bxptr]; prevbox[bxptr]←q; q←bxptr; bxptr←r;
	xll[q]←xll[q]+2; yll[q]←yll[q]+8;
	end;
bxptr←q;

ch←openofil(proof); out(ch,cutpage) # begin a new page of output;
out(ch,'012&'177&'003&'000&50) # insert page number and time at XGP row 50;
out(ch,'177&'001&'040&'000&100) # beginning at XGP column 100;
out(ch,'177&'006&0) # selecting font 0;
out(ch,prfheader&cvs(prfpno←prfpno+1));
if pagewarning then out(ch,"     "&pagewarning);
out(ch,'177&'006&1) # then select font 1;

p←0; if points then while llink[p]>p do p←llink[p] # go to the topmost leftmost point;
for y←yhigh step -1 until ylow do
	begin while bxptr and yll[bxptr]≥y do
		begin comment Outputting a point label;
		movetorow(yll[bxptr]);
		movetocol(xll[bxptr]);
		out(ch,strng[bxptr]);
		bxptr←prevbox[bxptr];
		end;
	movetorow(y);
	while p and ycoord[p]≥y do
		begin comment Outputting a point dot;
		if ycoord[p]=y and xcoord[p]≥xl and xcoord[p]≤xr then
			begin movetocol(xcoord[p]); out(ch,".");
			end;
		if (r←rlink[p])≤p then p←r
		else	begin p←r; while (r←llink[p])>p do p←r;
			end;
		end;
	comment Now output all grey cells in row $y$;
	state←0; curx←xl; movetocol(curx);
	for x←xleft thru xright do
		begin integer xw # position in \\{rast};
		integer z # current bit pattern;
		integer k # number of unscanned bits in $z$;
		integer zt,zr,zb,zl # bit patterns of neighbors;
		xw←x*rspan+y; z←rast[xw];
		k←bitsperwd; if z then
			begin zl←z lsh -1; zr← z lsh 1;
			if x≠xleft then zl←(rast[xw-rspan] lsh(bitsperwd-1))lor zl;
			if x≠xright then zr←(rast[xw+rspan] lsh(1-bitsperwd))lor zr;
			if y≠yhigh then zt←rast[xw+1] else zt←0;
			if y≠ylow then zb←rast[xw-1] else zb←0;
			if z=-1 and zt=-1 and zr=-1 and zb=-1 and zl=-1 then
				begin if state<0 then clearstate;
				state←state+bitsperwd; k←z←0;
				end
			else	begin zt←zt rot 1; zr←zr rot 2; zb←zb rot 3;
				zl←zl rot 4 # now these are in convenient position;
				end;
			while z do
				begin if z≥0 then
					begin if state>0 then clearstate;
					state←state-1;
					end
				else	begin integer c; c←(zt land 1)+(zr land 2)+
						(zb land 4)+(zl land 8);
					if c=15 then
						begin if state<0 then clearstate;
						state←state+1;
						end
					else	begin string chr; chr←'117 xor c;
						if state≠0 then clearstate;
						out(ch,chr); curx←curx+1;
						end;
					end;
				z←z lsh 1; k←k-1;
				zt←zt rot 1; zr←zr rot 1; zb←zb rot 1; zl←zl rot 1;
				end;
			end;
		if k then
			begin if state>0 then clearstate;
			state←state-k;
			end;
		end;
	end;
while bxptr do
	begin comment Outputting any remaining point labels;
	movetorow(yll[bxptr]);
	movetocol(xll[bxptr]);
	out(ch,strng[bxptr]);
	bxptr←prevbox[bxptr];
	end;
movetorow((ylow-70)min(yextra-50));
end;
comment Routines for chr mode.

In this mode we output the characters in asterisk-dot form. Exactly two
columns have more than one dot, these columns specifying the pixels to the
left and right of the character (columns -1 and chardw).
Exactly one row has more than two dots, this row being the baseline (row 0);

procedure makechr # outputs the current character to .chr file;
begin integer xrk,xl,xr,xw,y,yl,yh,z,lz,xlb,lkd,rkd,bsd,ch,xwr,x,bits,xx;
label nonblank1,nonblank2,nonblank3,nonblank4;
if chardw<0 then
	begin chardw←0; error("Negative chardw, replaced by 0");
	end
else if chardw>xrastmax+xpenmax then overflow(xrastmax+xpenmax);
xrk←rcol(chardw);
xl←xleft min rcol(-1); xr←xright max xrk;
while xl<rcol(-1) do
	begin comment try to eliminate blank column at left;
	xw←xl*rspan;
	for y←xw+ylow thru xw+yhigh do if rast[y] then go to nonblank1;
	xl←xl+1;
	end;
nonblank1: while xr>xrk do
	begin comment try to eliminate blank column at right;
	xw←xr*rspan;
	for y←xw+ylow thru xw+yhigh do if rast[y] then go to nonblank2;
	xr←xr-1;
	end;
nonblank2: yl←ylow min 0; yh←yhigh max 0;
while yl<0 do
	begin comment try to eliminate blank row at bottom;
	for xw←xleft*rspan+yl step rspan until xright*rspan+yl do
		if rast[xw] then go to nonblank3;
	yl←yl+1;
	end;
nonblank3: while yh>0 do
	begin comment try to eliminate blank row at top;
	for xw←xleft*rspan+yh step rspan until xright*rspan+yh do
		if rast[xw] then go to nonblank4;
	yh←yh-1;
	end;
nonblank4:if xl=rcol(-1) then z←1 lsh (hw+1) else z←0; xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
lz←0; while z>0 do
	begin lz←lz+1; z←z lsh 1;
	end;
xlb←1-hw+lz+bitsperwd*(xl-rcol(0));

ch←openofil(chrs);
out(ch,'14&"'"&cvos(charcode)&nextline);
y←yh; lkd←rkd←bsd←0;
while y≥yl or lkd≤1 or rkd≤1 do
	begin label rowdone;
	xw←xl*rspan+y; xwr←xr*rspan+y;
	x←xlb; z←rast[xw] lsh lz; bits←bitsperwd-lz;
	loop	begin if bits=0 then
			begin bits←bitsperwd; xw←xw+rspan; z←rast[xw];
			end;
		if z<0 then out(ch,"*")
		else if x=-1 then
			begin out(ch,"."); lkd←lkd+1;
			end
		else if x=chardw then
			begin out(ch,"."); rkd←rkd+1;
			end
		else if y=0 then
			begin label nonblank;
			if z=0 and x>chardw and bsd>2 then
				begin for xx←xw+rspan step rspan until xwr do
					if rast[xx] then go to nonblank;
				go to rowdone;
				end;
			nonblank: out(ch,"."); bsd←bsd+1;
			end
		else 	begin label nonblank;
			if z=0 and x>chardw then
				begin for xx←xw+rspan step rspan until xwr do
					if rast[xx] then go to nonblank;
				go to rowdone;
				end;
			nonblank: out(ch," ");
			end;
		z←z lsh 1; bits←bits-1; x←x+1;
		end;
	rowdone: out(ch,nextline); y←y-1;
	end;
end;
comment Routines for fnt mode.

In this mode we output the characters in binary format as required by the
XGP conventions documented in "Find a Font" by Les Earnest,
SAIL Operating Note 74, May 1976, as subsequently modified to allow negative
left kerns and to pack data according to raster_width instead of character_width;

define ytop=⊂fntdir['203]⊃, maxwdth=⊂fntdir['202]⊃, maxdpth=⊂fntdir['201]⊃;
procedure makefnt # outputs the current character to .fnt file;
begin integer xl,xr,z,xw,y,lz,xlb,xrb,lzr,yl,yh,ch,xlw,lz1,xrw;
integer rasterwidth,datarowcount,rowsfromtop,leftkern,wordcount;
label nonblank3,nonblank4,outchar;
ch←openofil(xgpfnt);
if chardw<0 then
	begin chardw←0; error("Negative chardw, replaced by 0");
	end;
xl←xleft; xr←xright; z←0;
loop	begin comment try to eliminate blank column at left;
	xw←xl*rspan;
	for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
	if z then done;
	xl←xl+1;
	if xl>xr then
		begin comment blank raster;
		rasterwidth←rowsfromtop←datarowcount←leftkern←wordcount←0;
		go to outchar;
		end;
	end;
lz←0; while z>0 do
	begin lz←lz+1; z←z lsh 1;
	end;
xlb←(1-hw-bitsperwd*rcol(0))+lz+bitsperwd*xl;
z←0;
while xr>xl do
	begin comment try to eliminate blank column at right;
	xw←xr*rspan;
	for y←xw+ylow thru xw+yhigh do z←z lor rast[y];
	if z then done;
	xr←xr-1;
	end;
lzr←(bitsperwd-1)-bit_id[((z land(-z))lsh -1) mod 37];
xrb←(1-hw-bitsperwd*rcol(0))+lzr+bitsperwd*xr;
yl←ylow; yh←yhigh;
loop	begin comment try to eliminate blank row at bottom;
	for xw←xl*rspan+yl step rspan until xr*rspan+yl do
		if rast[xw] then go to nonblank3;
	yl←yl+1;
	end;
nonblank3:
loop	begin comment try to eliminate blank row at top;
	for xw←xl*rspan+yh step rspan until xr*rspan+yh do
		if rast[xw] then go to nonblank4;
	yh←yh-1;
	end;
nonblank4: if yh>ytop then
	begin error("Character '"&cvos(charcode)&" goes over the top ("&
		cvs(yh)&" > "&cvs(ytop)&")");
	yh←ytop;
	end;
if chardw<xlb then
	begin lz←(chardw+(hw-1)) mod bitsperwd; xlb←chardw; xl←rcol(chardw);
	end;
maxwdth←maxwdth max chardw;
maxdpth←maxdpth min yl;

rasterwidth←xrb-xlb+1;
datarowcount←yh-yl+1;
wordcount←if rasterwidth>hw then ((rasterwidth-1) div bitsperwd + 1)*datarowcount
	else (datarowcount-1) div (bitsperwd div rasterwidth) + 1;
leftkern←-xlb;
rowsfromtop←ytop-yh;

outchar: 
if fntdir[charcode] then error("Duplicate charcode: '"&cvos(charcode));
fntdir[charcode]←(chardw lsh hw)+fntptr;
comment The next two lines assume that bitsperwd=36;
wordout(ch,(rasterwidth lsh 27)+(charcode lsh 18)+wordcount+2);
wordout(ch,(leftkern lsh 27)+(rowsfromtop lsh 18)+datarowcount);
fntptr←fntptr+2+wordcount;

if rasterwidth=0 then return;
xlw←xl*rspan; lz1←lz-bitsperwd;
if rasterwidth≤hw then
	begin integer bits,accum;
	bits←accum←0;
	for y←xlw+yh step -1 until xlw+yl do
		begin z←(rast[y] lsh lz)+(rast[y+rspan] lsh lz1);
		accum ← accum lor (z lsh (-bits));
		bits←bits+rasterwidth;
		if bits+rasterwidth>bitsperwd then
			begin wordout(ch,accum);
			bits←accum←0;
			end;
		end;
	if bits then wordout(ch,accum);
	end
else	begin xrw←xr*rspan; if lz>lzr then xrw←xrw-rspan;
	for y←yh step -1 until yl do for xw←y+xlw step rspan until y+xrw do
		wordout(ch,(rast[xw]lsh lz)+(rast[xw+rspan]lsh lz1));
	end;
end;
comment Routines for tfx mode.

This mode is a rather tedious set of routines that pack information into the
format TEX wants;

integer nwd,nht,ndp,ndw,nic;
internal integer nkr,nlg # table pointers in tfx mode;
internal saf integer array tfxdir[0:'177] # tfx mode character table;
internaldef wds=6,hts=4,dps=4,ics=6,dws=6,lgs=9 # sizes of tfx fields;
define wdmsk=(1 lsh wds)-1,htmsk=(1 lsh hts)-1,dpmsk=(1 lsh dps)-1,
	icmsk=(1 lsh ics)-1,dwmsk=(1 lsh dws)-1;
internaldef lgmsk=(1 lsh lgs)-1 # maximum ligature field;
internaldef lgd=wds+hts+dps+ics+dws # ligature displacement;
saf real array tfxwd[0:wdmsk+1] # tfx width table;
saf real array tfxht[0:htmsk+1] # tfx height table;
saf real array tfxdp[0:dpmsk+1] # tfx depth table;
saf integer array tfxic[0:icmsk+1] # tfx italic-correction (and misc) table;
saf integer array tfxdw[0:dwmsk+1] # tfx device-width table;
internal saf integer array tfxlg[1:lgmsk+'177] # tfx ligature-and-kern codes;
internal saf real array tfxkr[0:lgmsk+'177] # tfx kern values;
internaldef tfxparsize=24 # max number of tfx parameters;
internal saf real array tfxpars[1:tfxparsize] # tfx parameters;
internal integer tfxptr # number of tfx parameters stored;
preload_with true; saf boolean array tfxnot[0:0] # tfx mode initialized;

internal procedure tfxinit # ensures that tfx tables have been initialized;
if tfxnot[0] then
	begin integer ch,i; ch←openofil(tfx);
	for i←0 thru '177 do tfxdir[i]←0; nwd←nht←ndp←ndw←nkr←-1;
	nic←nlg←0; tfxic[0]←0 # zero ital correction is same as no ital correction;
	tfxptr←0;
	tfxnot[0]←false;
	end;

procedure maketfx # enters tfx information for current character;
begin integer jwd,jht,jdp,jic,jdw,intic;
tfxinit;
tfxwd[nwd+1]←charwd; jwd←0; while tfxwd[jwd]≠charwd do jwd←jwd+1;
if jwd>nwd then if nwd<wdmsk then nwd←jwd else
	begin real diff; integer k; diff←abs(tfxwd[0]-charwd); jwd←0;
	for k←1 thru wdmsk do 
		begin real delta; delta←abs(tfxwd[k]-charwd);
		if delta<diff then
			begin diff←delta; jwd←k;
			end;
		end;
	error("Rounding of charwd necessary, "&cvf(charwd)&" → "&cvf(tfxwd[jwd]));
	end;
tfxht[nht+1]←charht; jht←0; while tfxht[jht]≠charht do jht←jht+1;
if jht>nht then if nht<htmsk then nht←jht else
	begin real diff; integer k; diff←abs(tfxht[0]-charht); jht←0;
	for k←1 thru htmsk do 
		begin real delta; delta←abs(tfxht[k]-charht);
		if delta<diff then
			begin diff←delta; jht←k;
			end;
		end;
	error("Rounding of charht necessary, "&cvf(charht)&"→"&cvf(tfxht[jht]));
	end;
tfxdp[ndp+1]←chardp; jdp←0; while tfxdp[jdp]≠chardp do jdp←jdp+1;
if jdp>ndp then if ndp<dpmsk then ndp←jdp else
	begin real diff; integer k; diff←abs(tfxdp[0]-chardp); jdp←0;
	for k←1 thru dpmsk do 
		begin real delta; delta←abs(tfxdp[k]-chardp);
		if delta<diff then
			begin diff←delta; jdp←k;
			end;
		end;
	error("Rounding of chardp necessary, "&cvf(chardp)&"→"&cvf(tfxdp[jdp]));
	end;
tfxdw[ndw+1]←chardw; jdw←0; while tfxdw[jdw]≠chardw do jdw←jdw+1;
if jdw>ndw then if ndw<dwmsk then ndw←jdw else
	begin error("Too many different chardw values");jdw←ndw;
	end;
intic←memory[location(charic),integer];
tfxic[nic+1]←intic; jic←0; while tfxic[jic]≠intic do jic←jic+1;
if jic>nic then if nic<icmsk then nic←jic else
	begin error("Too many different charic/varchar values");jic←nic;
	end;
tfxdir[charcode]←((((((((((tfxdir[charcode] lsh -lgd) lsh dws) + jdw) lsh ics)
	+ jic) lsh dps) + jdp) lsh hts) + jht) lsh wds) + jwd;
end;

procedure tfxout # this procedure writes out the accumulated TEX information;
begin integer ch,j;
while tfxptr<7 do tfxpars[tfxptr←tfxptr+1]←0;
ch←openofil(tfx);
wordout(ch,tfxptr+(128+6+5+2)+nht+nwd+ndp+nic+nlg+nkr+ndw);
arryout(ch,tfxdir[0],128);
wordout(ch,nwd+1);
wordout(ch,nht+1);
wordout(ch,ndp+1);
wordout(ch,nlg+nkr+1);
wordout(ch,nic);
wordout(ch,ndw+1);
arryout(ch,tfxwd[0],nwd+1);
arryout(ch,tfxht[0],nht+1);
arryout(ch,tfxdp[0],ndp+1);
for j←1 thru nlg do if tfxlg[j] land (all_ones lsh -1)≥'200 lsh hw
	then tfxlg[j]←tfxlg[j]+((nlg-j) lsh hw);
if nlg>0 and tfxlg[nlg]≥0 then
	begin error("Ligature/kern table didn't end");
	tfxlg[nlg]←tfxlg[nlg] lor (1 lsh (bitsperwd-1));
	end;
arryout(ch,tfxlg[1],nlg);
arryout(ch,tfxkr[0],nkr+1);
arryout(ch,tfxic[1],nic);
arryout(ch,tfxdw[0],ndw+1);
arryout(ch,tfxpars[1],6);
wordout(ch,maxht);
wordout(ch,octaltime);
arryout(ch,tfxpars[7],tfxptr-6);
end;
comment Routines for Alphatype fonts;

integer offset # character to be shifted up this amount by typesetting routine;
integer alfch # channel being used for crsmode;
integer offptr # number of entries in offtable;
saf integer array offtable[1:10] # offsets used so far;

comment Routines that set up Alphatype font format;

comment Cleaning up the picture;

saf integer array zz[0:6] # temporary storage;

procedure clean # removes anomalies from the raster image;
begin comment The effect of this procedure is (a) to expand the raster
image so that every white pixel is part of a 7x7 square of white pixels, then
(b) to contract the result of (a) so that every black pixel is part of a 7x7
square of black pixels. The method is discussed in the CS204 class notes
from autumn 1978;
integer y,z,xw,x,xwh,k,u;
label phase1,phase2,phase3,phase4,phase5;
comment Phase 1 replaces x[i,j] by x[i,j] ∨ ... ∨ x[i-6,j];
phase1:
for y←ylow thru yhigh do
	begin z←0;
	for xw←xleft*rspan+y step rspan until (xright+1)*rspan+y do
		begin integer t,tt; t←rast[xw];
		tt←t lor (t lsh -1);
		tt←tt lor (tt lsh -2);
		rast[xw]←tt lor (tt lsh -3) lor (-(z land -z));
		z←t lsh (bitsperwd-6);
		end;
	end;

comment Phase 2 replaces x[i,j] by z[i,j] ∧ ... ∧ z[i,j+6], where
		z[i,j] = x[i,j] ∨ ... ∨ x[i,j-6];
phase2:
for x←xleft thru xright+1 do
	begin xw←x*rspan+ylow;
	zz[1]←rast[xw] lor rast[xw+1]; zz[2]←zz[1] lor rast[xw+2];
	zz[3]←zz[2] lor rast[xw+3]; zz[4]←zz[3] lor rast[xw+4];
	zz[5]←zz[4] lor rast[xw+5]; zz[6]←zz[5] lor rast[xw+6];
	k←6; xwh←xw-ylow+yhigh-1; while xw<xwh do
		begin xw←xw+1; k←k+1; if k>6 then k←0;
		if xw+5≤xwh then zz[k]←rast[xw] lor rast[xw+1] lor rast[xw+2] lor
			rast[xw+3] lor rast[xw+4] lor rast[xw+5] lor rast[xw+6]
		else	begin integer xwi,acc; acc←rast[xw]; xwi←xw;
			while xwi≤xwh do
				begin xwi←xwi+1; acc←acc lor rast[xwi];
				end;
			zz[k]←acc;
			end;
		rast[xw]←zz[0] land zz[1] land zz[2] land zz[3] land zz[4] land
			zz[5] land zz[6];
		end;
	end;

comment Phase 3 replaces x[i,j] by x[i-6,j] ∧ ... ∧ x[i+6,j];
phase3:
for y←ylow thru yhigh do
	begin xw←xleft*rspan+y; xwh←xright*rspan+y; z←0; u←rast[xw];
	while xw≤xwh do
		begin integer w,u1,u2,t,tt;
		comment Now $z$ and $u$ hold the former values of $\\{rast}[\\{xw}
			-\\{rspan}]$ and $\\{rast}[\\{xw}]$;
		w←rast[xw+rspan];
		u1←(z lsh (bitsperwd-6)) lor (u lsh -6);
		u2←(w lsh (6-bitsperwd)) lor (u lsh +6);
		comment The following code works if $\\{bitsperwd}≥24$;
		t←u1 land (u1 lsh -1);
		t←t land (t lsh -2);
		t←t land (t lsh -4);
		t←t land (t lsh -5);
		tt←u2 land (u2 lsh 1);
		tt←tt land (tt lsh 2);
		tt←tt land (tt lsh 4);
		tt←tt land (tt lsh 5);
		rast[xw]←(t lsh 12) lor (tt lsh -12);
		xw←xw+rspan; z←u; u←w;
		end;
	rast[xwh+rspan]←0;
	end;

comment Phase 4 replaces x[i,j] by z[i,j] ∨ ... ∨ z[i,j+6], where
		z[i,j] = x[i,j] ∧ ... ∧ x[i,j-6];
phase4:
for x←xleft thru xright do
	begin xw←x*rspan+ylow;
	zz[0]←zz[1]←zz[2]←zz[3]←zz[4]←zz[5]←0;
	k←6; xwh←xw-ylow+yhigh; while xw≤xwh do
		begin
		if xw+6≤xwh then zz[k]←rast[xw] land rast[xw+1] land rast[xw+2] land
			rast[xw+3] land rast[xw+4] land rast[xw+5] land rast[xw+6]
		else zz[k]←0;
		rast[xw]←zz[0] lor zz[1] lor zz[2] lor zz[3] lor zz[4] lor
			zz[5] lor zz[6];
		xw←xw+1; k←k+1; if k>6 then k←0;
		end;
	end;

comment Phase 5 replaces x[i,j] by x[i,j] ∨ ... ∨ x[i+6,j];
phase5:
for y←ylow thru yhigh do
	begin z←0;
	for xw←xright*rspan+y step -rspan until xleft*rspan+y do
		begin integer t,tt; t←rast[xw] land (all_ones lsh (bitsperwd-6));
		tt←((rast[xw] land (all_ones lsh -6)) lor z) rot 6;
		tt←tt lor (tt lsh -1);
		tt←tt lor (tt lsh -2);
		rast[xw]←tt lor (tt lsh -3) lor (-(t land -t));
		z←t;
		end;
	end;
end;
comment The following procedure converts a bit pattern to its boundary,
in the rectangle specified by xleft, xright, ylow, and yhigh, assuming that
the bit pattern does not have the consecutive bits "0 1 0" in any row or column.
The boundary is stored in linked form in the \\{blink} array, where each
entry has three fields \\{dir}, \\{ll}, \\{rr}. The \\{ll} and \\{rr} fields
are pointers to the next boundary edge of a cycle, and \\{dir} specifies the
orientation of the vertices at these connecting links:

	dir=0	means \\{ll} is one step west of \\{rr},
	dir=1	means \\{ll} is one step south of \\{rr},
	dir=2	means \\{ll} is one step southwest of \\{rr},
	dir=3	means \\{ll} is one step southeast of \\{rr}.

No explicit coordinates of points are given in such linked entries. However,
before every word whose \\{ll} and \\{rr} fields both point to subsequent nodes,
an additional word in the \\{blink} array specifies $x$ and $y$ coordinates of
the \\{ll} part of the following word. For example, the boundaries of

			******
			******
			**  **
			**  **
			******
			******

where the lower left corner point has coordinates (0,0) and the upper right corner
point has coordinates (5,5) would be represented thus:

	entry  dir  ll  rr		entry  dir  ll  rr
	 01	    (4, 5)		 16	1   20  11
	 02	0   03  07		 17	1   22  13
	 03	0   04  02		 18	1   23  14
	 04	0   05  03		 19	1   24  15
	 05	0   06  04		 20	2   21  16
	 06	0   08  05		 21	0   22  20
	 07	1   09  02		 22	3   21  17
	 08	1   14  06		 23	1   25  18
	 09	1   15  07		 24	1   26  19
	 10         (4, 3)		 25	1   30  23
	 11	3   16  12		 26	0   27  24
	 12	0   13  11		 27	0   28  26
	 13	2   17  12		 28	0   29  27
	 14	1   18  08		 29	0   30  28
	 15	1   19  09		 30	0   25  29

Boundary edges are recognized by 2x2 squares

			ab
			dc

as follows:

	abcd=1100	means edge ab
	abcd=0110	means edge bc
	abcd=0011	means edge cd
	abcd=1001	means edge ad
	abcd=1011 or 1110 means edge ac
	abcd=0111 or 1101 means edge bd.

It can be proved that these edges touch every vertex 0 or 2 times. The edges are
entered in the \\{blink} table from top to bottom, right to left. In the above
example the edges corresponding to entries 02, 03, ..., 30 can be depicted thus:

		*06*05*04*03*02*
	       08	       07
		*  *  *12*  *  *
	       14   13    11   09
		*  *        *  *
	       18  17      16  15
		*  *	    *  *
	       23   22    20   19
		*  *  *21*  *  *
	       25	       24
		*30*29*28*27*26*
;
define rrd=0,rrs=15,lld=15,lls=15,dird=30,dirs=bitsperwd-dird # fields;
define stlink(aa,bb)=⊂if type(aa) then setfield(rr,blink[vmemint(aa)],bb)
	else setfield(ll,blink[vmemint(aa)],bb)⊃;

integer bptr # number of entries in \\{blink};
define blinkmax=1006*12;
saf integer array blink[1:blinkmax+1];

procedure boundarize;
begin integer y,x,xw,xw0,za,zb,zc,zd,t,tt,zz,prevb;
integer a # pointer to list of "open" vertices on row $y+1$;
integer b # pointer to list of "open" vertices on row $y$;

y←yhigh; a←0; bptr←0; mem[0]←0;
while y≥ylow-1 do
	begin mem[temphead]←0; b←temphead;
	xw←xright*rspan+y; xw0←(xleft-1)*rspan+y; x←(xright+1)*bitsperwd;
	za←zd←0;
	while xw≥xw0 do
		begin integer z5,z6,w # edges of various types;
		zb←za lsh (1-bitsperwd);
		if y<yhigh and xw>xw0 then za←rast[xw+1] else za←0;
		zb←(za lsh 1)+zb;
		zc←zd lsh (1-bitsperwd);
		if y≥ylow and xw>xw0 then zd←rast[xw] else zd←0;
		zc←(zd lsh 1)+zc;

		t←za xor zc; tt←zb xor zd;
		z5←tt land za land zc;
		z6←t land zb land zd;
		w←t land tt;
		zz←w lor z5 lor z6 # z1 ∨ ... ∨ z6;

		while zz do
			begin integer xx,zzz,xxx,d,aa;
			label case1,case2,case3,case4,case5,case6,upcase,
				newb,insbd,insd;
			zzz←zz land -zz # least 1; zz←zz xor zzz;
			xx←x-bit_id[(zzz lsh -1) mod 37] # relative $x$ coordinate;
			comment Here we are assuming that $\\{bitsperwd}≤36$;
			xxx←xx # $x$ coordinate in row $y+1$;
			bptr←bptr+1;
			if bptr>blinkmax then return # too much boundary;
			if zzz land w then
				if zzz land za then
					if zzz land zb then go to case1
					else go to case4
				else if zzz land zb then go to case2
					else go to case3
			else if zzz land z5 then go to case5 else go to case6;

			case1: comment Now $\\{name}(a)=\\{xx}+1$;
			d←0;
			stlink(a,bptr); blink[bptr]←vmemint(a);
			aa←link(a); if name(aa)=xx then
				begin stlink(aa,bptr);
				blink[bptr]←blink[bptr]+(vmemint(aa) lsh lld);
				freeavail(a); a←link(aa); freeavail(aa); go to insd;
				end
			else	begin mem[a]←(mem[a] land ((1 lsh typed)-1))
					-(1 lsh named);
				vmemint(a)←bptr; go to insd;
				end;
			
			case2: d←1 lsh typed; xx←xx+1; xxx←xxx+1; go to upcase;
			case5: d←3 lsh typed; xx←xx+1; go to upcase;
			case6: d←2 lsh typed; xxx←xxx+1; go to upcase;
			case4: d←1 lsh typed;
			upcase: if name(a)=xxx then
				begin stlink(a,bptr); blink[bptr]←vmemint(a);
				if name(b)=xx then
					begin stlink(b,bptr);
					blink[bptr]←blink[bptr]+(vmemint(b)lsh lld);
					aa←link(a); freeavail(a); a←aa;
					freeavail(b); b←prevb; go to insd;
					end
				else 	begin setlink(b,a); prevb←b; b←a; a←link(a);
					go to insbd;
					end;
				end
			else if name(b)=xx then
				begin stlink(b,bptr); blink[bptr]←vmemint(b)lsh lld;
				aa←b; b←prevb; vmemint(aa)←bptr;
				mem[aa]←(xxx lsh named)+a+(1 lsh typed); a←aa;
				go to insd;
				end
			else	begin getvavail(aa);
				blink[bptr]←(xx lsh lld)+y-(yrastmin+ypenmin-1);
				bptr←bptr+1; vmemint(aa)←bptr;
				mem[aa]←(xxx lsh named)+a+(1 lsh typed); a←aa;
				go to newb;
				end;

			case3: d←0; if name(b)=xx+1 then
				begin stlink(b,bptr); blink[bptr]←vmemint(b);
				mem[b]←mem[b]-(1 lsh named); vmemint(b)←bptr;
				go to insd;
				end
			else	begin getvavail(aa); setlink(b,aa); b←aa;
				blink[bptr]←(xx lsh lld)+y-(yrastmin+ypenmin-1);
				bptr←bptr+1; vmemint(b)←bptr;
				mem[b]←((xx+1) lsh named)+(1 lsh typed);
				go to newb;
				end;

			newb: getvavail(aa); setlink(b,aa); prevb←b; b←aa;
			insbd: vmemint(b)←bptr; mem[b]←xx lsh named;
			insd: blink[bptr]←blink[bptr]+d;
			end;
		xw←xw-rspan; x←x-bitsperwd;
		end;
	y←y-1; setlink(b,0); a←link(temphead);
	end;
end;
comment Conversion to Alphatype format;

saf integer array byte[1:1008] # encoded boundary data;
preload_with	6, 7, 8, 9,10,11,12,
		5, 0, 0, 0, 0, 0,13,
		4, 0, 6, 9,12, 0,14,
		3, 0, 3, 0,15, 0,15,
		2, 0, 0,21,18, 0,16,
		1, 0, 0, 0, 0, 0,17,
		0,23,22,21,20,19,18; saf integer array dircode[7*(-3)-3:7*3+3];
preload_with 7,0,0,6,0,0,5,0,0,4,0,0,3,0,0,2,0,0,1,0,0,0; integer array newcode[0:21];
preload_with -1,0,-1,+1; saf integer array dxt[0:3];
preload_with 0,-1,-1,-1; saf integer array dyt[0:3];
preload_with '30,'20,'10,1,2,3,4,5,6,7,'70,'60,'50;
	saf integer array movecode[-6:+6];
preload_with 0,-1,-2,0,-1,-2,0,2,1,0,2,1,0; saf integer array correction[-6:+6];


procedure crscode;
begin label toobig;
integer counter;
integer i # number of \\{blink} entries examined for cycle leaders;
integer ii # number of output bytes;
integer qq # extra byte times;
integer minx,maxx # extremes of $x$ coordinates;
integer xc # current $x$ coordinate;
integer d # current direction code (0 = SE, 3 = S, 6 = SW, ..., 21 = E);
integer p,q,r # pointers that traverse the boundary;
integer acc # three-bit codes or code fragments not yet output;
integer b # number of bits in \\{acc};
integer bytetimes # total number of byte times in the character;

if bptr>blinkmax then go to toobig;

i←ii←0; qq←7; minx←10000; maxx←-10000;
loop	begin integer x0,y0 # starting coordinates of a cycle;
	i←i+1; if i>bptr then done;
	if blink[i]=0 then continue;
	i←i+1; if blink[i]=0 then continue;
	print('15&'12);counter←0;
	xc←x0←field(ll,blink[i-1])+(360-rcol(0)*bitsperwd-hw);
	y0←field(rr,blink[i-1])+(369-1+yrastmin+ypenmin)-offset;
	comment Point (0,0) actually has coordinates
		(rcol(0)*bitsperwd+hw,1-(yrastmin+ypenmin)) in blink;
	p←i+1; q←i;
	if field(dir,blink[i])=0 then 
		begin print(4); counter←1;
		end;
	if ii>1006-7 then go to toobig;
	byte[ii+1]←0; byte[ii+2]←x0 land '377; byte[ii+3]←'140+(x0 lsh -8);
	byte[ii+4]←y0 land '377; byte[ii+5]←y0 lsh -8;
	if ii>0 then ii←ii+5
	else	begin byte[3]←byte[3] lor '30 # "zz=11" on first cycle;
		for ii←6 thru 13 do byte[ii]←'377;
		ii←13;
		end;

	comment Now traverse the boundary;
	d←9 # initial direction is west;
	blink[q]←0;
	acc←b←0;
	loop	begin comment Now get next change of direction;
		integer n # number of boundary bits to go in current direction;
		integer c # next direction change;
		integer dx,dy # local change in $x$ and $y$ for next step;
		integer dd # direction code;
		n←0;
		loop	begin dx←dy←0;
			loop	begin r←field(ll,blink[p]);
				if r=0 then
					begin dx←-1; done # end of cycle, go west;
					end;
				dd←field(dir,blink[p]);
				if r=q then
					begin r←field(rr,blink[p]);
					dx←dx-dxt[dd]; dy←dy-dyt[dd];
					end
				else	begin dx←dx+dxt[dd]; dy←dy+dyt[dd];
					end;
				blink[p]←0; q←p; p←r;
				if abs(dx)=1 or abs(dy)=1 then done;
				end;
			xc←xc+dx;
			if xc<minx then minx←xc; if xc>maxx then maxx←xc;
			dd←dircode[7*dx+dy];
			print(newcode[dd]);
			counter←counter+1; if counter=64 then
				begin print('15&'12); counter←0;
				end;
			done;
			end;
		if blink[p]=0 then done;
		end;
	end;
bytetimes←ii+(qq lsh -3);
if bytetimes>1006 then go to toobig;

if maxht=696969 then
	begin print(nextline,nextline,"Data for character '",cvos(charcode));
	print(nextline,"fntptr='",cvos(fntptr));
	print(nextline,"offset='",cvos(offset)," (",(3*offset)div 10," fu)");
	print(nextline,"minx='",cvos(minx));
	print(nextline,"maxx='",cvos(maxx));
	print(nextline,"bytetimes='",cvos(bytetimes));
	print(nextline,"alfptr='",cvos(alfptr));
	print(nextline,"There are ",ii," boundary bytes, namely:");
		begin integer i;
		i←0;
		while i<ii do
			begin if i land 7 = 0 then print(nextline);
			i←i+1;
			print("'",cvos(byte[i]),",");
			end;
		end;
	end;

comment Now the data is output to the font file;
begin integer x # random number;
integer i # number of bytes output;
if fntptr≥'200*initblocks then overflow(initblocks);
fntdir[fntptr]←((3*offset)div 10) land ((1 lsh hw)-1);
fntdir[fntptr+1]←(minx lsh hw)+maxx;
fntdir[fntptr+2]←(bytetimes lsh hw)+alfptr;
fntdir[fntptr+3]←charwd*(1 lsh hw)+.5;
fntptr←fntptr+4; alfptr←alfptr+1+((ii+3) div 4);
wordout(alfch,ii);
i←0; x←fntdir['200]; 
while i<ii do
	begin x←367965721*x+256854611;
	wordout(alfch,(x lsh -4) xor ((((((byte[i+1] lsh 8) +
		byte[i+2]) lsh 8) + byte[i+3]) lsh 8) + byte[i+4]));
	i←i+4;
	end;
end;
return;

toobig: error("Boundary too long"); fntdir[charcode]←0;
end;

procedure alfout # outputs portion of character in crsmode;
begin comment ylow and yhigh are multiples of 10, and we will output
rows ylow thru yhigh inclusive;
if yhigh-ylow>1020 then
	begin error("Character too tall ("&cvs(ylow)&"..."&cvs(yhigh)&")");
	yhigh←ylow+1020;
	end;
if yhigh≤760 and ylow≥-260 then offset←0
else	begin comment We try to minimize the number of distinct offsets;
	integer i; label found;
	for i←1 thru offptr do if yhigh-offtable[i]≤760 and ylow-offtable[i]≥-260 then
		begin offset←offtable[i]; go to found;
		end;
	if offptr=10 then if yhigh>760 then offset←yhigh-760 else offset←ylow+260
	else	begin offptr←offptr+1;
		offset←10*((yhigh+ylow-490) div 20);
		offtable[offptr]←offset;
		end;
	found:
	end;
boundarize; crscode;
end;

procedure makealf # outputs the current character to .ant file;
begin integer j,yl,yh;
yl←ylow; yh←yhigh;
alfch←openofil(alf);
if fntdir[charcode] then error("Duplicate charcode: '"&cvos(charcode));
j←brkptr; while j>0 do
	begin if brktab[j]≤ylow+6 or brktab[j]≥yhigh-6 then
		begin integer k; comment Remove a break near the bottom or top;
		k←j; while k<brkptr do
			begin brktab[k]←brktab[k+1]; k←k+1;
			end;
		brkptr←brkptr-1;
		end;
	j←j-1;
	end;
fntdir[charcode]←((brkptr+1) lsh hw)+fntptr;
brktab[0]←10*(((ylow+30000) div 10)-3000);
brktab[brkptr+1]←10*(((yhigh+30010) div 10)-3000);
comment the entries of brktab are all multiples of 10;
for j←0 thru brkptr do
	begin ylow←brktab[j]; yhigh←brktab[j+1];
	alfout;
	end;
ylow←yl; yhigh←yh;
end;
internal procedure initout # get TEXOUT started properly;
begin integer i # runs from 1 to numberofmodes;
maintitle←ofilname←null;
no_output_yet←true;
for i←1 thru numberofmodes do ochan[i]←-1;
ofilext[tfx]←".tfx"; ofilext[xgpfnt]←".fnt"; ofilext[proof]←".xgp";
ofilext[alf]←".ant"; ofilext[chrs]←".chr";
octaltime←call(0,"ACCTIM"); timeofday←daytime;
tptr←1; llink[0]←rlink[0]←0;
offptr←0;
end;

internal procedure charclear # initializes parameters for a new character;
begin charwd←chardp←charht←charic←0.0;
chardw←0; charcode←-1;
brkptr←0; brktab[0]←1 lsh (bitsperwd-1);
end;
internal procedure finishchar # outputs a finished character;
begin if chardisplay then ddoutrast;
if charcode≥0 and charcode<'200 then
	begin if xleft=infty then
		begin comment blank character;
		xleft←xright←rcol(0); yhigh←ylow←0;
		end;
	if chrmode then makechr;
	if proofmode then makeproof;
	if tfxmode then maketfx;
	if fntmode then makefnt;
	if crsmode then 
		begin makealf;
		if chardisplay then ddoutrast # show raster in case it changed;
		end;
	clearrast;
	end
else if xleft<infty then
	begin if proofmode then makeproof else
		error("Image lost since charcode not specified");
	clearrast;
	end;
llink[0]←0; tptr←1 # clear the symbol table;
end;
internal procedure closeout # finishes off the output;
begin
if ochan[chrs]≥0 then
	begin release(ochan[chrs]);
	print(nextline,"Characters for editing written on file ",flname[chrs]);
	end;
if ochan[alf]≥0 then
	begin useto(alfch,1) # reposition font file at its beginning;
	arryout(alfch,fntdir[0],'200*initblocks) # write the directories;
	release(alfch);
	print(nextline,"Images written on ",flname[alf]);
	end;
if ochan[xgpfnt]≥0 then
	begin useto(ochan[xgpfnt],1) # reposition font file at its beginning;
	fntdir['203]←fntdir['203]+1 # this seems to work;
	fntdir['201]←fntdir['203]-fntdir['201] # max(rowsfromtop+datarowcount);
	arryout(ochan[xgpfnt],fntdir[0],'400) # write the font directory;
	release(ochan[xgpfnt]);
	print(nextline,"Images written on ",flname[xgpfnt]);
	end;
if ochan[tfx]≥0 then
	begin tfxout;
	release(ochan[tfx]);
	print(nextline,"TEX information written on ",flname[tfx]);
	end;
if ochan[proof]≥0 then
	begin release(ochan[proof]);
	print(nextline,"Proof figures written on file ",flname[proof]);
	ptostr(0,"r xgpsyn;"&flname[proof]&"/L");
	end;
end;
end